perm filename INTERP.PAL[HAL,HE]13 blob
sn#172539 filedate 1975-08-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 .SBTTL Interpreter
C00008 00003 Interpreter itself: INTERP
C00014 00004 GETARG, GETSCA, GETVEC, GETTRN
C00018 00005 Variable declaration: MVAR, KVAR
C00021 00006 Stack ops: GTVAL, IGTVAL, CHNGE, ICHNGE, PUSH, POP, COPY, REPLACE, FLUSH
C00026 00007 Flow-of-control: PROC, RETURN
C00032 00008 FORCHK, JUMP, JUMPC
C00035 00009 SPAWN, SPROUT, TERMINATE
C00043 00010 Graph node handlers: MCLC, ENDCLC
C00047 00011 MCHGR, GTOLD, GTNEW
C00050 00012 return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG
C00056 00013 Vector utilities: UNITV, CROSV
C00062 00014 Return vectors: SVMUL, TVMUL, VMAKE, VADD
C00066 00015 Return a trans: TMAKE, TVADD, TTMUL
C00071 00016 Motion: MOVE
C00073 00017 Condition monitors: CMMAK
C00079 00018 CMENBL, CMDSBL, CMDEST, CMTRIG, CMSKED, CMUNCR, CMBWT
C00085 00019 Events: MAKEVT, SIGNAL, WAITE, DESEVT
C00090 00020 Debugging aids: PRINT, PRNTS
C00094 00021 BREAK, NOOP, TOPAL, IOINIT
C00096 ENDMK
C⊗;
.SBTTL Interpreter
COMMENT ⊗
Register uses in the interpreter:
R5 used by some routines as the display register
R4 points to interpreter status block
R3 interpreter stack pointer
R2 not used by the main interpreter loop. Can be munged by
any primary interpreter routine.
Each interpreter has a stack which it uses to store pointers to
currently "open" variables. During the course of a calculation,
operands and temporary result cells will be open in this fashion.
The "interpreter stack" is pointed to by R3. When a new interpreter
is sprouted, it is given a new stack area. Each interpreter has
certain status information which facilitates transfer of control
between interpreters. This information is kept in the interpreter
status block, which is always pointed to by R4. Most important are
the IPC, the Interpreter Program Counter, the ENV, which points to
the local environment, and LEV, which stores the current lexical
level.
Each procedure has an environment, which is a data area holding
information vital to that procedure. This includes pointers to all
the variables local to that procedure, and return information. ⊗
INSTSZ == 20 ;Size of an interpreter stack
;Interpreter status block
II == 0
XX IPC ;Interpreter program counter. Leave this as first field!
XX NXTINT ;Next interpreter in the list. For GC of the stacks.
XX STKBAS ;Location of start of stack area. Needed
;for eventual reclamation.
XX ENV ;Location of local environment
XX LEV ;Lexical level of current execution
XX STA ;Status bits for condition codes: 0 means all well.
XX PCB ;Location of process control block (for reclamation)
XX EVT ;The event to signal as this interpreter goes away
XX CMCB ;Pointer to c-m control block if this is a checker or a body
XX OLDV ;The "old value" used by changers
XX NEWV ;The "new value" used by changers
.IFNZ ALAID ;Special debugging information
XX DEBMOD ;The mode bits for debugging.
ALDSS == 1 ;1 => Single step mode
.ENDC
ISBS == II/2 ;Size (in words) of interpreter status block
;Fixed fields in the environment of each process
II == 0
XX SLINK ;Pointer to environment of next (outer, lower
; numbered) block
XX OLEV ;Old level. The lexical level of calling process.
XX OENV ;Old environment, the one for the calling process.
XX OIPC ;Old IPC. Program counter for calling process.
XX LVARS ;First location where pointers to local variables go
INTEVT: 0 ;The event that interlocks references to ISTBLK.
;Interpreter itself: INTERP
.MACRO MAKEOP CNAME, ANAME ;Compiler name, Address name
XX CNAME
ANAME
.ENDM
;The interpreter operation table
INTOPS: MAKEOP XINVALID,INVALID ;Illegal instruction
.INSRT INTOPS.PAL[HAL,HE]
INSEND = II ;Marks the end of the instructions
.MACRO BMPIPC ;
ADD #2,IPC(R4) ;Bump IPC
.ENDM ;
.MACRO CCC ;Clear condition code
CLR R0 ;Clear condition code
.ENDM
.MACRO SCC ;Set condition code
MOV #2,R0 ;Set condition code
.ENDM
.IFZ ALAID ;The ALAID version is in ALAID.PAL
INTERP:
MOV R3,R0 ;Save the limit of the interpreter stack for error checking.
SUB #INSTSZ-2,R0
MOV R0,-(SP) ;
INT1: CMP R3,(SP) ;Interpreter stack overflow?
BGE INT3 ;No. Go to next instruction.
HALERR INTMS3 ;Yes. Complain.
INT3: MOV @IPC(R4),R0 ;R0 ← next instruction
BLE INVALID ;Instruction out of range
CMP R0,#INSEND ;Is instruction too large?
BLE INT2 ;No.
INVALID:HALERR INTMS1 ;Yes. complain.
INT2: BMPIPC ;Bump IPC
JSR PC,@INTOPS(R0) ;Call the appropriate routine
BR INTCPL(R0) ;R0 should have an completion code. Branch accordingly.
INTCPL: BR INT1 ;No error. Repeat.
HALERR INTMS2 ;Error. Complain.
BR INT1 ;And repeat.
INTMS1: ASCIE /INTERPRETER INSTRUCTION OUT OF RANGE/
INTMS2: ASCIE /INTERPRETED INSTRUCTION RETURNED FAILURE/
INTMS3: ASCIE /INTERPRETER STACK OVERFLOW/
.ENDC
; GETARG, GETSCA, GETVEC, GETTRN
GETARG:
COMMENT ⊗
Arguments:
R0=variable name: high byte is lexical level, low byte is offset.
R4=pointer to interpreter status block.
Result:
R0← pointer to address of desired variable.
R1 clobbered.
This routine returns in R0 a pointer to the location in the current
environment (or, if necessary, more global environment) which
points to the variable which is named in R0. ⊗
MOV R2,-(SP) ;Save R2
MOVB R0,R1 ;R1 ← Offset desired
CLRB R0 ;
SWAB R0 ;R0 ← Lexical level
MOV ENV(R4),R2 ;R2 ← LOC[local environment]
SUB LEV(R4),R0 ;R0 ← Difference in levels: desired-got
BEQ GTRG1 ;Diff=0; can use R2 as pointer at right base.
BHI GTERR ;If diff>0, then value inaccessible.
GTRG2: MOV SLINK(R2),R2;Must go up a level. R2 ← LOC[more global environment]
INC R0 ;R0 ← New difference in levels
BNE GTRG2 ;If not yet good, then move up another level
GTRG1: ADD R2,R1 ;R1 ← environment + offset = location of desired pointer
MOV (SP)+,R2 ;Restore R2.
MOV R1,R0 ;
RTS PC ;Done.
GTERR: HALERR GTMS1
GTMS1: ASCIE /ATTEMPT TO ACCESS UNAVAILABLE VARIABLE/
GETSCA: ;Gets place for a scalar result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #SCASPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #2,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETVEC: ;Gets place for a vector result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #VCTSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #10,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETTRN: ;Gets place for a trans result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
.IFNZ SMALLB
MOV #TRNSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #40,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
;Variable declaration: MVAR, KVAR;
MVAR:
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, a fresh graph node
is created (with no value) and a pointer to it is placed in the
environment at the desired offset, current level. ⊗
MOV @IPC(R4),-(SP) ;push offset
BEQ MVAR1 ;If none, done
BMPIPC ;Bump IPC
CLR R0 ;The new graph node should get no value cell.
JSR PC,MAKEGN ;R0 ← LOC[a new graph node]
ADD ENV(R4),(SP);stack pointer into environment
MOV R0,@(SP)+ ;Point the environment to the graph node
BR MVAR ;Repeat
MVAR1: TST (SP)+ ;Clean off stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
KVAR:
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, the corresponding
graph node is destroyed in the current environment. Any function in
the graph structure is thereby released. (Attempt is made to
validate any dependents first.) ⊗
MOV @IPC(R4),R2 ;R2 ← offset
BEQ KVAR1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R2 ;R2 ← LOC[pointer at graph node]
MOV (R2),R0 ;R0 ← LOC[graph node]
JSR PC,DELGN ;Get this guy deleted
CLR (R2) ;Remove the pointer in the environment
BR KVAR ;Repeat
KVAR1: BMPIPC ;Bump IPC
CCC ;Clear condition code
RTS PC ;Done
;Stack ops: GTVAL, IGTVAL, CHNGE, ICHNGE, PUSH, POP, COPY, REPLACE, FLUSH
GTVAL:
COMMENT ⊗ The argument is a level-offset pair. The variable
referenced by that pair is examined and a pointer to its value cell
is placed on the stack. ⊗
MOV @IPC(R4),R0 ;Pick up level-offset name of argument
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[desired graph node]]
MOV (R0),R0 ;R0 ← LOC[desired graph node]
BEQ GTVL2 ;But if 0, then bug
CALL GETVAL,<R0>;R0 ← value
GTVL3: MOV R0,-(R3) ;Push value on interpreter stack.
BEQ GTVL1 ;But if 0, then bug
CCC ;Clear condition code.
RTS PC ;Done
GTVL1: HALERR GTVMS1 ;Complain
SCC ;Set condition code
RTS PC ;Done
GTVL2: HALERR GTVMS2 ;Complain
BR GTVL3 ;But comply
GTVMS1: ASCIE </GTVAL FOUND A NULL VALUE. MAY CONTINUE/>
GTVMS2: ASCIE </GTVAL FOUND A NULL GRAPH NODE. MAY CONTINUE/>
IGTVAL:
COMMENT ⊗ Immediate version of GTVAL. The argument points directly
to the graph node whose value is desired. A pointer to the value
cell is placed on the stack. ⊗
MOV @IPC(R4),R0 ;R0 ← LOC[desired graph node]
BMPIPC ;Bump IPC
CALL GETVAL,<R0>;R0 ← value
MOV R0,-(R3) ;Push value on interpreter stack.
CCC ;Clear condition code.
RTS PC ;Done
CHNGE:
COMMENT ⊗ Pops the value from top of stack into the graph structure
pointed to by the level-offset pair given in the argument. ⊗
MOV @IPC(R4),R0 ;Pick up level-offset name of argument
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[Desired graph node]]
MOV (R0),R0 ;R0 ← LOC[Desired graph node]
BEQ CHNGE1 ;If any
CALL CHANGE,<R0,(R3)>
POP: TST (R3)+ ;Pop stack
CCC ;Clear condition code.
RTS PC ;Done
CHNGE1: HALERR CHNMES ;Complain
TST (R3)+ ;Get rid of the value
SCC ;Set condition code
RTS PC ;Done
CHNMES: ASCIE </CAN'T ASSIGN INTO UNINITIALIZED VARIABLE/>
ICHNGE:
COMMENT ⊗ Immediate version of CHNGE. Pops the value from top of
stack into the graph structure pointed to directly by the argument. ⊗
MOV @IPC(R4),R0 ;R0 ← LOC[desired graph node]
BMPIPC ;Bump IPC
CALL CHANGE,<R0,(R3)>
TST (R3)+ ;Pop stack
CCC ;Clear condition code.
RTS PC ;Done
PUSH: MOV @IPC(R4),-(R3);Put argument directly on stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
; Interpreter routine. Copies the nth element in stack to the top,
; where the curent top is 0.
COPY: MOV @IPC(R4),R0 ;Pick up argument.
BMPIPC ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied to top]
MOV (R0),-(R3) ;Copy it onto top of stack.
CCC ;Clear condition code.
RTS PC ;Done
REPLAC: MOV @IPC(R4),R0 ;Pick up argument.
BMPIPC ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied into]
MOV (R3)+,(R0) ;Copy verge of stack into it.
CCC ;Clear condition code.
RTS PC ;Done
FLUSH: MOV STKBAS(R4),R3;Reset the stack base.
CCC ;Clear condition code.
RTS PC ;Done
;Flow-of-control: PROC, RETURN
PROC:
;Procedure call. Arguments:
; Destination.
; List of variables which are to be inserted in appropriate
; locations in the local storage of procedure. These are
; in the format variable (ie level-offset pair), new offset
; (right justified in the second word).
; There is a zero word to finish these.
;At the destination address can be found:
II == 0
XX FSLGTH ;Number of words to get from free storage
;for local variable pointers
XX PLEV ;Lexical level of procedure
DSLGTH == II ;Number of words before code starts
;Value parameters should have first been copied first into local temps
; (which have been arranged by the compiler), and then the temps are
; passed by reference. Eventual problem: to know which variables to
; really kill as the procedure is exited.
MOV @IPC(R4),R2 ;R2 ← LOC[destination]
BMPIPC ;Bump IPC
MOV FSLGTH(R2),R0 ;R0 ← Number of words to get.
JSR PC,GTFREE ;R0 ← LOC[block with that number of words]
;initialize pointer to lexical level:
MOV PLEV(R2),R1 ;R1 ← Lexical level of procedure
MOV ENV(R4),R2 ;R2 ← LOC[current environment]
SUB LEV(R4),R1 ;R1 ← Difference in levels: desired-got
BEQ PRC1 ;Diff=0; can use R2 as pointer at right environment.
PRC2: MOV SLINK(R2),R2;No, must go up a level. R2 ← LOC[base of upper area]
INC R1 ;R1 ← New difference in levels
BNE PRC2 ;If not yet good, then move up another level
PRC1: MOV R2,SLINK(R0);SLINK[new environment] ← correct global environment
;Put copies of local variables in new area
MOV R0,-(SP) ;Stack LOC[new environment]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BEQ PRC3 ;If there are no more, go to next phase
PRC4: BMPIPC ;Else bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[graph node]]
MOV @IPC(R4),R1 ;R1 ← offset in new block
BMPIPC ;Bump IPC
ADD (SP),R1 ;R1 ← LOC[place in new environment to put pointer]
MOV (R0),(R1) ;new environment gets pointer to LOC[argument graph node]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BNE PRC4 ;If there are more, go back and treat them
PRC3: BMPIPC ;Bump IPC one last time
;Save the old context in the new area
MOV (SP)+,R1 ;R1 ← LOC[new environment]
MOV LEV(R4),OLEV(R1) ;Store the old level
MOV ENV(R4),OENV(R1) ;Store the old environment location
MOV IPC(R4),OIPC(R1) ;Store the return address
;Set up the new context for procedure
MOV PLEV(R2),LEV(R4) ;New lexical level
MOV R1,ENV(R4) ;New environment location
ADD #DSLGTH,R2 ;R2 ← Place where execution should begin
MOV R2,IPC(R4) ;New program counter
CCC ;Clear condition code.
RTS PC ;Done
RETURN:
;Returns from a procedure call to calling program. Since variables are
;passed by reference, it is not necessary to do any copying of values.
;All that is needed is to restore the context of the caller and to
;discard the display.
MOV ENV(R4),R0 ;R0 ← LOC[current environment]
MOV OLEV(R0),LEV(R4) ;Restore the old lexical level
MOV OENV(R0),ENV(R4) ;Restore the old environment
MOV OIPC(R0),IPC(R4) ;Restore the IPC
JSR PC,RLFREE ;Release storage of old display
CCC ;Clear condition code.
RTS PC ;Done
; FORCHK, JUMP, JUMPC
FORCHK:
;Assume that the stack has, from surface in, the increment, the
; final value, and the control variable's value, all of which are
; scalar values. If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
; no-op; otherwise, jump to the destination.
;Arguments: destination.
LDF @2(R3),AC0 ;AC0 ← final value
SUBF @4(R3),AC0 ;AC0 ← final - current
MULF @(R3),AC0 ;AC0 ← (final - current)*increment
MOV @IPC(R4),R0 ;R0 ← destination
BMPIPC ;Bump IPC
CFCC ;
BGE FOR1 ;Shall this be a no-op?
MOV R0,IPC(R4) ;No; set new IPC.
FOR1: CLR R0 ;
RTS PC ;Done
JUMP:
;Takes one argument: the new address.
MOV @IPC(R4),IPC(R4)
CCC ;Clear condition code.
RTS PC ;Done
JUMPC: ;Interpreter routine
COMMENT ⊗ Two arguments: the condition and the destination address.
The condition queries the top of the stack and pops it, assuming it
to be a scalar. The interpreter jumps to the destination address if
the condition is satisfied. The possible conditions are 0(Never),
1(L), 2(E), 3(LE), 4(Always), 5(GE), 6(NE), 7(G). Note that
comparisons of equality must be exact to floating precision. ⊗
MOV @IPC(R4),R2 ;R2 ← condition
BMPIPC ;Bump IPC
BLT JMPCERR ;If out of range, complain.
MOV R2,R0 ;
SUB #7,R0 ;
BGT JMPCERR ;
MOV (R3)+,R0 ;R0 ← LOC[arg]
LDF (R0),AC0 ;AC0 ← arg
ADD R2,R2 ;
ADD R2,R2 ;Multiply condition by 4.
CFCC ;
JMP JMPC3(R2) ;Go to the right test.
JMPC3: BR JMPC1 ;N always fail
BR JMPC4 ;
BGE JMPC1 ;L
BR JMPC4 ;
BNE JMPC1 ;E
BR JMPC4 ;
BGT JMPC1 ;LE
BR JMPC4 ;
TST R0 ;A never fail
BR JMPC4 ;
BLT JMPC1 ;GE
BR JMPC4 ;
BEQ JMPC1 ;NE
BR JMPC4 ;
BLE JMPC1 ;G
JMPC4: MOV @IPC(R4),IPC(R4) ;Succeed
BR JMPC2 ;
JMPC1: BMPIPC ;Fail. Bump IPC
JMPC2: CCC ;Clear condition code.
RTS PC ;Done
JMPCER: HALERR JMPCMS ;
JMPCMS: ASCIE </ILLEGAL JUMPC CODE/>
; SPAWN, SPROUT, TERMINATE
SPAWN: ;Utility routine
COMMENT ⊗ Takes two arguments: In R0, the IPC of the interpreter to
spawn, and in R1, the event (if any) to put in EVT of the new
interpreter. The inferior will have the same environment as the
superior. Creates an interpreter status block, stack, process
descriptor, and is ready for a SCHEDU when it returns the process
descriptor in R0. ⊗
MOV R1,-(SP) ;Save the EVT
MOV R0,-(SP) ;Save the new IPC
MOV #ISBS,R0 ;R0 ← Size (in words) of an interpreter status block
JSR PC,GTFREE ;R0 ← LOC[new interpreter status block]
MOV (SP)+,IPC(R0);new IPC ← first argument
MOV ENV(R4),ENV(R0) ;new ENV ← old ENV
MOV LEV(R4),LEV(R0) ;new LEV ← old LEV
.IFNZ ALAID
MOV DEBMOD(R4),DEBMOD(R0) ;new DEBMOD ← old DEBMOD
.ENDC
EVWAIT INTEVT ;Interlock sensitive operation.
MOV #NXTINT+ISTBLK,R1 ;Link into the interpreter list.
MOV (R1),NXTINT(R0) ;
MOV R0,(R1) ;
EVSIG INTEVT ;End of interlock
MOV (SP)+,EVT(R0);new EVT ← second argument.
MOV R0,-(SP) ;Save LOC[new interpreter status block]
MOV #INSTSZ,R0 ;R0 ← Size needed for an interpreter stack
JSR PC,GTFREE ;R0 ← LOC[new interpreter stack]
MOV (SP)+,R1 ;R1 ← LOC[new interpreter status block]
MOV R0,STKBAS(R1) ;Store away new stack base
ADD #2*INSTSZ,R0 ;R0 ← LOC[top of new stack] (INSTSZ is in bytes)
MOV R1,-(SP) ;Save R1
MOV R0,-(SP) ;Save R0
MOV #210,R0 ;Room for process descriptor
JSR PC,GTFREE ;R0 ← LOC[new process descriptor]
MOV #UFPUSE+UGRSAV,PDBSTA(R0);Use floating point, use saved registers.
MOV #420,UPDLEN(R0) ;Length of PCB
; MOV (R2),PDBR2(R0) ;Transfer register 2 (not currently necessary)
MOV (SP)+,R1 ;R1 ← LOC[new interpreter stack top]
MOV R1,PDBR3(R0) ;Store away new interp stack pointer (reg 3)
MOV (SP)+,R1 ;R1 ← LOC[new ISB]
MOV R0,PCB(R1) ;Store away LOC[PCB] in new ISB
MOV R1,PDBR4(R0) ;Store away LOC[ISB] in reg 4 of PCB
; MOV R5,PDBR5(R0) ;Store away reg 5 (not currently necessary)
MOV SP,R1 ;
TST (R1)+ ;
MOV R1,PDBSP(R0) ;Store away the new stack pointer (reg 6)
MOV #INTERP,PDBPC(R0);Store away the new PC
RTS PC ;Done
; These are the appropriate scheduling commands:
; SCHEDU R0,#INTERP,#0,#2;Cause the new process to be started, suspended
; FORK R0,#INTERP,#0 ;Cause the new process to be started.
SPROUT: ;Interpreter routine
COMMENT ⊗ Arguments: One address in pseudo-code for each of the
several forks starting up, followed by a 0 word. This is to be used
only for cobegins, not for servos. Each new interpreter is given an
interpreter status block and is then scheduled. As each terminates,
it signals its defining event. Since each of these has the same
event, the current interpreter need only wait until they all happen.
⊗
MOV R3,-(SP) ;Save R3. Caution: cannot use interpreter stack now.
CLR R3 ;R3 is the count of how many inferiors to spawn.
EVMAK ;-(SP) ← Event identifier for communication with infs.
SPR2: MOV @IPC(R4),R0 ;R0 ← next argument (IPC)
BEQ SPR1 ;If zero, then we have spawned all the inferiors.
BMPIPC ;Bump IPC
INC R3 ;Count it.
MOV (SP),R1 ;R1 ← event for the inferior EVT
JSR PC,SPAWN ;R0 ← process control block of new interpreter
SCHEDU R0,#INTERP,#0,#2;Cause the new process to be started, suspended
BR SPR2 ;Go handle the next inferior.
SPR1: BMPIPC ;Bump IPC
SPR4: DEC R3 ;Another wait to be done?
BMI SPR3 ;No, we are finished.
EVWAIT (SP) ;Wait for an inferior to come back.
BCC SPR4 ;If all well, wait for the next one.
HALERR SPRMES ;The event was killed!
SPR3: EVKIL (SP)+ ;Kill the event now, remove from stack
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code.
RTS PC ;Done
SPRMES: ASCIE /BAD RETURN FROM INFERIOR/
TERMINATE:
COMMENT ⊗ Interpreter routine, sometimes jumped to from other
interpreter routines. End this interpreter. ⊗
MOV EVT(R4),R0 ;R0 ← event to announce imminent demise
BEQ TERM1 ;If there is one
EVSIG R0 ;Announce that we are about to disappear.
TERM1: MOV STKBAS(R4),R0 ;Reclaim interpreter stack
JSR PC,RLFREE ;
MOV PCB(R4),R0 ;Reclaim process control block (may be dangerous)
JSR PC,RLFREE ;
MOV R4,R0 ;Reclaim Interpreter Status Block
JSR PC,RLFREE ;
EVWAIT INTEVT ;Enter critical region.
MOV #ISTBLK,R0 ;The following unlinks this interpreter from the chain.
TERM3: MOV R0,R1 ;
MOV NXTINT(R1),R0;
CMP R0,R4 ;Have we found ours yet?
BNE TERM3 ;
MOV NXTINT(R4),NXTINT(R1); Yes. rechain.
EVSIG INTEVT ;Leave critical region.
DISMIS ;Go away
;Graph node handlers: MCLC, ENDCLC;
COMMENT ⊗ Make a calculator for a graph node. This involves several
data: the target variable, specified as a level-offset pair, the
location of the calculator code, (which is ordinary interpreter code
which leaves one value on the interpreter stack and then calls
ENDCLC, which puts that value in R0 and returns), and the list of
needed cells for the calculation. These data are passed as arguments
to MCLC: target (level-offset), IPC (absolute address), needed list
(list of level-offsets, terminated by 0). Recall that a calculator
cell looks like this:
II==0
XX NXTCLC ;next calculator cell in chain
XX NEEDED ;list of needed nodes. Each is a cell link whose datum
; is an absolute pointer and which is only forward linked.
XX CLCISB ;Points to interpreter status block to resolve addressing
XX CLCIPC ;the interpeter PC where the calculation starts
CLCCSZ == II/2;Size of calculator cell, in words
⊗
MCLC: ;Interpreter routine.
MOV R2,-(SP) ;Save R2
MOV R3,-(SP) ;Save R3
MOV #CLCCSZ,R0 ;Get room for a calculator cell
JSR PC,GTFREE ;
MOV R0,R3 ;R3 ← LOC[new calculator cell]
MOV R4,CLCISB(R3) ;store away ISB
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[target graph node]]
MOV (R0),R2 ;R2 ← LOC[target graph node]
MOV @IPC(R4),CLCIPC(R3) ;store away target IPC
BMPIPC ;Bump IPC
;form the needed list
CLR -(SP) ;Start with null needed list on the stack
MCLC2: MOV @IPC(R4),R0 ;R0 ← the next needed level-offset
BEQ MCLC1 ;Any more?
JSR PC,GETARG ;R0 ← LOC[LOC[next needed graph node]]
MOV (R0),-(SP) ;Stack next needed graph node
BMPIPC ;Bump IPC
.IFNZ SMALLB ;Get a new cell for needed list
MOV #CELSPC,R0 ;
JSR PC,GETSBK ;Allocate from small blocks
.IFF
MOV #2,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
.ENDC
MOV (SP)+,DATUM(R0);Needed graph node
MOV (SP),LINKF(R0);Link to rest of needed list
MOV R0,(SP) ;New needed list
BR MCLC2 ;
MCLC1: BMPIPC ;Bump IPC
MOV (SP)+,NEEDED(R3) ;store away needed list
CALL ADDCLC,<R2,R3> ;Do the final linking
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code
RTS PC ;Done
ENDCLC: ;Interpreter routine. Called as last instruction in a calculator
;cell. Returns via an RTS RF. Does not unlink anything.
MOV RF,SP ;Reset the stack
TST -(SP) ;
MOV (R3)+,R0 ;Get the coveted value cell
RTS RF ;Will return to the calling point in EVLCLC.
; MCHGR, GTOLD, GTNEW
COMMENT ⊗ Make a changer for a graph node. This involves several
data: the target variable, specified as a level-offset pair, and the
location of the changer code, (which is ordinary interpreter code
which leaves one value on the interpreter stack and then calls
ENDCLC, which puts that value in R0 and returns). These data are
passed as arguments to MCHG: target (level-offset), IPC (absolute
address). Recall that a changer cell looks like this:
II==0
XX NXTCHG ;next changer cell in chain
XX CHGISB ;Points to interpreter status block to resolve addressing
XX CHGIPC ;the interpeter PC where the calculation starts
CHGCSZ == II/2 ;Size of changer cell, in words
⊗
MCHG: ;Interpreter routine.
MOV R2,-(SP) ;Save R2
MOV R3,-(SP) ;Save R3
MOV #CHGCSZ,R0 ;Get room for a changer cell
JSR PC,GTFREE ;
MOV R0,R3 ;R3 ← LOC[new changer cell]
MOV R4,CHGISB(R3) ;store away ISB
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[target graph node]]
MOV (R0),R2 ;R2 ← LOC[target graph node]
MOV @IPC(R4),CHGIPC(R3) ;store away target IPC
BMPIPC ;Bump IPC
CALL ADDCHG,<R2,R3> ;Do the final linking
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code
RTS PC ;Done
GTOLD: ;Interpreter routine
COMMENT ⊗ Gets the OLD value that this changer (acting as an
interpreter) has access to; puts it on the stack. ⊗
MOV OLDV(R4),-(R3)
CCC ;Clear condition code
RTS PC ;Done
GTNEW: ;Interpreter routine
COMMENT ⊗ Gets the NEW value that this changer (acting as an
interpreter) has access to; puts it on the stack. ⊗
MOV NEWV(R4),-(R3)
CCC ;Clear condition code
RTS PC ;Done
;return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG
COMMENT ⊗ All timings are averages of 1000 runs. They take into
account the cost of the RTS but not the JSR. It is assumed that
GETSCA and GETVEC take no time. All routines on this page are
interpreter routines. ⊗
;30 microseconds
SADD: ;Scalar ← Scalar + Scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
ADDF @(R3)+,AC0 ;AC0 ← arg2 + arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
SSUB: ;Scalar ← Scalar - Scalar
LDF @2(R3),AC0 ;AC0 ← arg 1
SUBF @(R3)+,AC0 ;AC0 ← arg1 - arg2
TST (R3)+ ;Move past first argument
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;30 microseconds
SMUL: ;Scalar ← scalar * scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
MULF @(R3)+,AC0 ;AC0 ← arg2 * arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;33 microseconds
SDIV: ;Scalar ← Scalar / Scalar
LDF @(R3)+,AC1 ;AC1 ← arg 2
LDF @(R3)+,AC0 ;AC0 ← arg 1
DIVF AC1,AC0 ;AC0 ← arg1 / arg2
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;26 microseconds
SNEG: ;Scalar ← -Scalar
LDF @(R3)+,AC0 ;AC0 ← arg
NEGF AC0 ;AC0 ← -arg
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CCC ;Clear condition code.
RTS PC ;Done
;96 -- 116 microseconds
VDOT: ;Scalar ← Vector dot Vector
;S ← (X1X2 + Y1Y2 + Z1Z2) / W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #3,R2 ;R2 ← 3: Length of vector
VDV1: LDF (R0)+,AC1 ;Form sum of products of first 3 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,VDV1 ;Loop until all 3 fields done.
DIVF (R0),AC0 ;Divide by W1
DIVF (R1),AC0 ;Divide by W2. AC0 now has answer.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code.
RTS PC ;Done
;103 -- 116 microseconds
PVDOT: ;Scalar ← Plane dot Vector
;S ← X1X2 + Y1Y2 + Z1Z2 + W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #4,R2 ;R2 ← 4: Length of vector and weight
PDV1: LDF (R0)+,AC1 ;Form sum of products of all 4 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,PDV1 ;Loop until all 3 fields done.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CCC ;Clear condition code.
RTS PC ;Done
;199 -- 207 microseconds
VMAGN: ;Scalar ← Norm (vector)
;S ← SQRT(XX + YY+ ZZ) / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Push LOC[W] onto system stack, to save across SQRTF
JSR PC,SQRTF ;AC0 ← SQRT(XX + YY + ZZ)
DIVF @(SP)+,AC0 ;AC0 ← AC0 / W
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store answer
CCC ;Clear condition code.
RTS PC ;Done
;Vector utilities: UNITV, CROSV
COMMENT ⊗ These are not currently being used
;281 -- 286 microseconds
UNITV: ;Vector ← V / Norm(V)
;S ← SQRT(XX + YY+ ZZ) / W
MOV (R3),R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Save R1 across SQRTF
JSR PC,SQRTF ;AC0 ← SQRT(XX + YY + ZZ)
MOV (SP)+,R1 ;Restore R1
DIVF (R1),AC0 ;AC0 ← Norm = SQRT / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R2 ;R2 ← count of fields
UNITV1: LDF (R1)+,AC1 ;AC1 ← field of vector
DIVF AC0,AC1 ;divide by norm
STF AC1,(R0)+ ;Store result
SOB R2,UNITV1 ;Loop until done
MOV (R1)+,(R0)+ ;Copy W.
MOV (R1),(R0) ; (two words long)
CCC ;Clear condition code
RTS PC ;Done
;172 -- 184 microseconds
CROSV: ;Vector ← Vector cross Vector
;X ← Y1Z2 - Y2Z1
;Y ← X2Z1 - X1Z2
;Z ← X1Y2 - X2Y1
;W ← W1W2
;AC0, 1, 2, 3, 4, 5 are garbaged by this routine.
MOV (R3),R2 ;R2 ← LOC[arg 2]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV 4(R3),R1 ;R1 ← LOC[arg 1]. Must not pop R3 stack yet!
LDF 14(R1),AC0 ;AC0 ← W1
MULF 14(R2),AC0 ;AC0 ← W1W2
STF AC0,14(R0) ;Store AC0 → W
LDF 4(R1),AC0 ;AC0 ← Y1
LDF (R2),AC1 ;AC1 ← X2
LDF 4(R2),AC2 ;AC2 ← Y2
LDF (R1),AC3 ;AC3 ← X1
STF AC3,AC4 ;AC4 ← X1
STF AC0,AC5 ;AC5 ← Y1
MULF AC2,AC3 ;AC3 ← X1Y2
MULF AC1,AC0 ;AC0 ← X2Y1
SUBF AC0,AC3 ;AC3 ← X1Y2 - X2Y1
STF AC3,10(R0) ;Z ← AC3
LDF 10(R2),AC0 ;AC0 ← Z2
LDF 10(R1),AC3 ;AC3 ← Z1
MULF AC4,AC0 ;AC0 ← X1Z2
MULF AC3,AC1 ;AC1 ← X2Z1
SUBF AC0,AC1 ;AC1 ← X2Z1 - X1Z2
STF AC1,4(R0) ;Y ← AC1
LDF 10(R2),AC0 ;AC0 ← Z2
MULF AC5,AC0 ;AC0 ← Y1Z2
MULF AC2,AC3 ;AC3 ← Y2Z1
SUBF AC3,AC0 ;AC0 ← Y1Z2 - Y2Z1
STF AC0,(R0) ;X ← AC0
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
CCC ;Clear condition code
RTS PC ;Done
⊗ END OF COMMENTED-OUT PROCEDURES.
;Return vectors: SVMUL, TVMUL, VMAKE, VADD
;83 -- 91 microseconds
SVMUL: ;Vector ← Scalar * Vector. Interpreter routine
;X ← S*X, Y ← S*Y, Z ← S*Z, W ← W
MOV (R3)+,R2 ;R2 ← LOC[vector]
LDF @(R3)+,AC0 ;AC0 ← scalar;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R1 ;R1 ← 3: How many fields to handle
SVM1: LDF (R2)+,AC1 ;AC1 ← next field of vector
MULF AC0,AC1 ;AC1 ← product
STF AC1,(R0)+ ;Store result
SOB R1,SVM1 ;Loop until all 3 fields done.
MOV (R2)+,(R0)+ ;Transfer W
MOV (R2)+,(R0)+ ; which is 2 words long.
CCC ;Clear condition code
RTS PC ;Done
VMAKE: ;Interpreter routine
LDF @(R3)+,AC1 ;Fetch X
LDF @(R3)+,AC2 ;Fetch Y
LDF @(R3)+,AC3 ;Fetch Z
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Store W
CLR (R0) ;Store W (second word)
CCC ;Clear condition code
RTS PC ;Done
VADD: ;Interpreter routine
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
LDF (R0)+,AC1 ;Calculate X
ADDF (R1)+,AC1 ;
LDF (R0)+,AC2 ;Calculate Y
ADDF (R1)+,AC2 ;
LDF (R0)+,AC3 ;Calculate Z
ADDF (R1)+,AC3 ;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Assume W is 1
CLR (R0) ;
CCC ;Clear condition code
RTS PC ;Done
;283 -- 324 microseconds
TVMUL: ;Vector ← Trans * Vector. Interpreter routine
MOV (R3),R2 ;R2 ← LOC[vector]
MOV 2(R3),R0 ;R0 ← LOC[trans]
CLRF AC1 ;X ← 0
CLRF AC2 ;Y ← 0
CLRF AC3 ;Z ← 0
MOV #4,R1 ;R1 ← How many columns left to go
TVM1: LDF (R2)+,AC0 ;AC0 ← field of vector
STF AC0,AC5 ;AC5 ← copy of AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC1 ;Add partial result to X
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC2 ;Add partial result to Y
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC3 ;Add partial result to Z.
ADD #4,R0 ;Skip bottom row
SOB R1,TVM1 ;Go back to do all 4 columns.
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV -4(R2),(R0)+;Copy W from the vector
MOV -2(R2),(R0) ; (2 words long)
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
CCC ;Clear condition code
RTS PC ;Done
;Return a trans: TMAKE, TVADD, TTMUL
TMAKE: ;Interpreter routine.
;All that is required is to take the rot part of the first argument,
;and the vector from the second part;
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
MOV (R3)+,-(SP) ;Push LOC[arg 2]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV #14,R2 ;R2 ← Count of how many copies to make
TMK1: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK1 ;Repeat until done
MOV (SP)+,R1 ;R1 ← LOC[arg 2]
MOV #4,R2 ;R2 ← Count of how many copies to make
TMK2: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK2 ;Repeat until done
CCC ;Clear condition code.
RTS PC ;Done.
TVADD: ;Interpreter routine.
;All that is required is to take the rot part of the first argument,
;and add the vector from the first part to the second argument.
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
MOV (R3)+,R2 ;R2 ← LOC[arg 2]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV R3,-(SP) ;Save R3
MOV #14,R3 ;R3 ← Count of how many copies to make
TVA1: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R3,TVA1 ;Repeat until done
MOV #3,R3 ;R3 ← Count of how many additions to perform
TVA2: LDF (R1)+,AC0 ;AC0 ← word from trans
ADDF (R2),AC0 ; + word from vector
STF AC0,(R0)+ ;
SOB R3,TVA2 ;Repeat until done
MOV ONE,(R0)+ ;Set last word to 1.0
CLR (R0) ;
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code.
RTS PC ;Done.
TTMUL: ;Interpreter routine
;Multiplies two transes together. Takes advantage of the fact that
;last row is 0 0 0 1.
MOV (R3)+,R2 ;R2 ← LOC[arg 2]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV R3,-(SP) ;Save R3
MOV R4,-(SP) ;Save R4
MOV #4,R4 ;Loop count for cols of answer
MOV R1,-(SP) ;Save a copy of R1
TTM2: LDF (R2)+,AC1 ;Pick up a column of arg2: First row
LDF (R2)+,AC2 ; Second row
LDF (R2)+,AC3 ; Third row
STF AC3,AC4 ; store in AC4
ADD #4,R2 ; Fourth row is zero
MOV #3,R3 ;Loop count for rows of answer
TTM1: LDF (R1),AC3 ;First col of arg 1
MULF AC1,AC3 ;
LDF 20(R1),AC0 ;Second col of arg 1
MULF AC2,AC0 ;
ADDF AC0,AC3 ;
LDF 40(R1),AC0 ;Third col of arg 1
MULF AC4,AC0 ;
ADDF AC0,AC3 ;
STF AC3,(R0)+ ;
ADD #4,R1 ;Move to next column of arg 1
SOB R3,TTM1 ;Repeat for first 3 rows of answer
CLR (R0)+ ;Last row of answer is zero
CLR (R0)+ ;
MOV (SP),R1 ;Reset R1 to point to first row of arg 1
SOB R4,TTM2 ;Repeat for all four columns of answer
LDF -20(R0),AC1 ;Add correction for last column, first row
ADDF 60(R1),AC1 ;
STF AC1,-20(R0) ;
LDF -14(R0),AC1 ;Add correction for last column, second row
ADDF 64(R1),AC1 ;
STF AC1,-14(R0) ;
LDF -10(R0),AC1 ;Add correction for last column, third row
ADDF 70(R1),AC1 ;
STF AC1,-10(R0) ;
MOV ONE,-4(R0) ;Make last col, last row get a one.
TST (SP)+ ;Pop the R1 temp
MOV (SP)+,R4 ;Restore R4
MOV (SP)+,R3 ;Restore R3
CCC ;Clear condition code
RTS PC ;Done
;Motion: MOVE
MOVE: ;Interpreter routine
COMMENT ⊗ Note that currently, the compiler puts out trans pointers
in offset form, but the servo expects this to have been resolved to
graph node pointers. MOVE should perhaps scan through the table and
resolve these the first time through, or else the servo preparation
can be told how to. (This latter is cleaner, but puts more burden on
the servo prep code and makes it less local.) ⊗
.IFNZ MOVING ;If this version is supposed to be able to move
MOV #33,R0 ;Get a device block
JSR PC,GTFREE ;
MOV R0,R1 ;R1 ← address of device block
MOV R0,-(SP) ;Save a copy on the stack
MOV @IPC(R4),R0 ;R0 ← address of coefficient list
BMPIPC ;Bump IPC
JSR PC,@LMOVE ;Put a move on
TST R0 ;All well?
BEQ MOV1 ;Yes
HALERR MOVERR ;No, better complain.
MOV1: MOV (SP)+,R0 ;
JSR PC,RLFREE ;Get rid of the device block
CCC ;Clear condition code
RTS PC ;Return
MOVERR: ASCIE </SERVO ERROR. ERROR BITS IN R0/>
.IFF ;If not a moving version
HALERR MOVERR ;Can't move
BMPIPC ;Bump IPC
CLR R0 ;
RTS PC ;Return
MOVERR: ASCIE </SORRY, THIS VERSION CAN'T EVEN LIFT A FINGER/>
.ENDC
;Condition monitors: CMMAK
.IFNZ ONMONS
COMMENT ⊗ This is the first, trivial version of condition monitors
(here refered to as c-m's). The basic operations are Creation,
Enabling, Disabling, Destruction. Creation causes a c-m control
block to be set up, and pointed to by the c-m variable. This block
has the following fields: ⊗
II == 0
XX CMSEVT ;The event used to awaken the tester
XX CMCEVT ;The event used to signal the conclusion
XX CMSTAT ;Status bits for the c-m
CMENB == 1 ;set => enabled
CMDES == 2 ;set => destroyed
CMCBSZ == II/2 ;Length in words of a c-m control block.
COMMENT ⊗ The once-only code of the checker is sprouted at priority 3
(it is an interpreter), and after initialization, it waits for the
gronking event CMSEVT. The body is sprouted at priority 1 (it should
reset itself to 0 after any critical section). Enabling signals
event CMSEVT and sets the enabled bit in CMSTAT. Disabling resets
the enabled bit, and the checker will wait on the CMSEVT for future
action. As long as the checker is enabled, it periodically wakes up,
checks its status bits. If the enable bit is reset, the checker
waits for CMSEVT. Else it checks the condition. If it is satisfied,
CMCEVT is signaled, and the checker disables itself. Otherwise, it
reschedules itself. If the destroy bit should ever be set in CMSTAT,
then the checker will destroy the event CMEVT, and the event CMSEVT.
Then it will reclaim the c-m control block and will dismiss, never to
return. (The pointer to the c-m in the environment should be zeroed
by the destroying angel.). ⊗
CMMAK: ;Interpreter routine
COMMENT ⊗ Takes three arguments, the offset of the nascent c-m, the
IPC of the checker code, and the IPC of the body code. ⊗
MOV @IPC(R4),R2 ;R2 ← offset
BMPIPC ;Bump IPC
ADD ENV(R4),R2 ;R2 ← Pointer into environment
TST (R2) ;Already something there?
BEQ CMMK1 ;
HALERR CMMMSG ;Yes. complain.
;Make a c-m control block
CMMK1: MOV #CMCBSZ,R0 ;
JSR PC,GTFREE ;R0 ← LOC[c-m control block]
MOV R0,(R2) ;Stuff into environment
EVMAK ;
MOV (SP)+,CMSEVT(R0) ;Make an event for CMSEVT
EVMAK ;
MOV (SP)+,CMCEVT(R0) ;Make an event for CMCEVT
CLR CMSTAT(R0) ;Disabled, undestroyed
MOV R0,-(SP) ;Save LOC[c-m control block]
;Prepare the checker
MOV @IPC(R4),R0 ;R0 ← IPC of checker code
BMPIPC ;Bump IPC
CLR R1 ;Checkers do not expire with events
JSR PC,SPAWN ;R0 ← process control block for checker
MOV PDBR4-PDBSTA(R0),R2;R2 ← PR4 (checker's interpeter status block)
MOV (SP),CMCB(R2);Stuff CMCB of the checker
FORK R0,#INTERP,#3;Cause the checker to be started. It will go into wait.
;Prepare the body
MOV @IPC(R4),R0 ;R0 ← IPC of body code
BMPIPC ;Bump IPC
CLR R1 ;Bodies do not expire with events
JSR PC,SPAWN ;R0 ← process control block for main body
MOV PDBR4-PDBSTA(R0),R2;R2 ← PR4 (body's interpreter status block)
MOV (SP)+,CMCB(R2);Stuff CMCB of the body
FORK R0,#INTERP,#1;Cause the body to be started. It will go into wait.
CCC ;Clear condition code
RTS PC ;Done
CMMMSG: ASCIE </CMMAK: WILL CREATE EXISTENT CONDITION MONITOR/>
; CMENBL, CMDSBL, CMDEST, CMTRIG, CMSKED, CMUNCR, CMBWT
CMNEMS: ASCIE </TRYING TO TREAT NON-EXISTENT EVENT/>
CMENBL: ;Interpeter routine
; One argument, a level-offset pair for the c-m to enable.
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← pointer into environment
MOV (R0),R0 ;R0 ← pointer to c-m control block.
BEQ CMDERR ;If none, then error
BIS #CMENB,CMSTAT(R0) ;Set the enable bit
EVSIG CMSEVT(R0) ;Gronk the c-m
CCC ;Clear condition code
RTS PC ;Done
CMEERR: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMDSBL: ;Interpreter routine
; One argument, a level-offset pair for the c-m to disable.
MOV @IPC(R4),R0 ;R0 ← level-offset
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← pointer into environment
MOV (R0),R0 ;R0 ← pointer to c-m control block.
BEQ CMDERR ;If none, then error
BIC #CMENB,CMSTAT(R0) ;Clear the enable bit
CCC ;Clear condition code
RTS PC ;Done
CMDERR: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMDEST: ;Interpreter routine
COMMENT ⊗ Argument list. Each is an offset for the c-m to destroy.
The list is terminated with a zero entry. ⊗
MOV @IPC(R4),R0 ;R0 ← offset
BEQ CMDS1 ;If 0, then done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
MOV (R0),R1 ;R1 ← LOC[c-m control block]
BEQ CMDSER ;If none, then error
BIS #CMDES,CMSTAT(R1) ;Set the destroy bit (RF -- necessary?)
EVKIL CMSEVT(R1);Wake up the checker with termination notice
CLR (R0) ;Remove c-m from environment
BR CMDEST ;Go do the next one.
CMDS1: BMPIPC ;Bump IPC the last time
CCC ;Clear condition code
RTS PC ;Done
CMDSER: HALERR CMNEMS ;
SCC ;Set condition code
RTS PC ;
CMTRIG: ;Interpeter routine
COMMENT ⊗ Should be executed only from a c-m checker. Causes the
body to be triggered, and disables the checker. The next
pseudo-instruction should be the scheduler, or a jump to it. ⊗
MOV CMCB(R4),R0 ;
EVSIG CMCEVT(R0);Trigger the body
CMTR1: EVTST CMSEVT(R0);Eat all signals enabling the checker.
BCC CMTR1 ;
BIC #CMENB,CMSTAT(R0) ;Clear the enable bit
CCC ;Clear condition code
RTS PC ;Done
CMSKED: ;Interpreter routine
COMMENT ⊗ Goes to sleep a while (currently, 100 milliseconds). Upon
awakening, checks the status bits of this checker, and either
dismisses, waits, or returns. ⊗
SLEEP #100 ;Sleep a while
MOV CMCB(R4),R0 ;
CMSK4: BIT #CMDES,CMSTAT(R0) ;Destroy bit set?
BEQ CMSK1 ;No
CMSK3: EVKIL CMCEVT(R0);Yes. Kill the triggering event. (The body will hear this.)
JMP TERMINATE ;Use the interpeter terminate routine.
CMSK1: BIT #CMENB,CMSTAT(R0) ;Enable bit set?
BNE CMSK2 ;Yes.
EVWAIT CMSEVT(R0);No. Wait until signaled.
BCS CMSK5 ;If the enabling event died, so must we.
BR CMSK4 ;Else start from the awakening point.
CMSK5:
BR CMSK3 ;
CMSK2: CCC ;Clear condition code
RTS PC ;Done
CMUNCR: ;Interpreter routine.
COMMENT ⊗ Used in body of c-m. Starts uncritical section. ⊗
MOV PCB(R4),R0 ;
CLR 2(R0) ;Clear word 1 of process control block to reset nominal
; priority to 0.
SETPRI #0 ;Set the priority to 0
CCC ;Clear condition code
RTS PC ;Done
CMBWT: ;Interpreter routine.
COMMENT ⊗ First operation in body of c-m. Waits on the CMCEVT. ⊗
MOV CMCB(R4),R0 ;
EVWAIT CMCEVT(R0);Wait until triggered.
BCC CMBW1 ;Event killed?
JMP TERMINATE ;Yes. Use the interpreter terminate routine.
CMBW1:
CCC ;Clear condition code
RTS PC ;Done
.ENDC ; End of the ONMON material
;Events: MAKEVT, SIGNAL, WAITE, DESEVT;
COMMENT ⊗ Events can be created (at the beginnings of blocks is the
usual place), signaled, awaited (in the middle of a block) and
destroyed (at the end of a block). Each event is a variable, that
is, it is refered to by a level-offset pair. However, its place in
the environment does not point to a graph node, since there is no
such thing as attachment to an event. The event itself is stored in
the environment. The garbage collector marking phase had better
understand this. ⊗
MAKEVT: ;Interpreter routine
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, a fresh event is
created and placed in the environment at the desired offset, current
level. ⊗
MOV @IPC(R4),R0 ;R0 ← offset
BEQ MAKEV1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
EVMAK ;Make an event.
MOV (SP)+,(R0) ;Stuff it away.
BR MAKEVT ;Repeat
MAKEV1: TST (SP)+ ;Clean off stack
BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
SIGNAL: ;Interpreter routine. Signal the event of the level-offset pair.
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← equivalent pointer into environment
EVSIG (R0) ;Signal that event.
CCC ;Clear condition code.
RTS PC ;Done
WAITE: ;Interpreter routine. Wait on the event of the level-offset pair.
MOV @IPC(R4),R0 ;R0 ← level-offset pair.
BMPIPC ;Bump IPC
JSR PC,GETARG ;R0 ← equivalent pointer into environment
EVWAIT (R0) ;Wait on that event.
BCS WAITE1 ;Return OK?
JMP TERMINATE ;The event was destroyed. I guess we should depart cleanly.
WAITE1:
CCC ;Clear condition code.
RTS PC ;Done
DESEVT: ;Interpreter routine
COMMENT ⊗ A list of arguments, each of which is an offset. This list
is terminated by a zero entry. For each argument, the event is
destroyed. ⊗
MOV @IPC(R4),R0 ;push offset
BEQ DESEV1 ;If none, done
BMPIPC ;Bump IPC
ADD ENV(R4),R0 ;R0 ← pointer into environment
EVKIL (R0) ;Kill the event
CLR (R0) ;Remove the event from the environment
BR DESEVT ;Repeat
DESEV1: BMPIPC ;Bump IPC
CCC ;Clear condition code.
RTS PC ;Done
;Debugging aids: PRINT, PRNTS
PRINT: ;Interpreter routine
MOV @IPC(R4),R0 ;R0 ← Address of string
BMPIPC ;Bump IPC
JSR PC,TYPSTR ;Type it out
CCC ;Clear condition code
RTS PC ;Done
PRNTS: ;Interpreter routine. Prints the scalar on the stack, pops
MOV #CRLFX,R0 ;
JSR PC,TYPSTR ;
MOV (R3)+,R2 ;R2 ← LOC[scalar value]
.IFNZ FLOAT
LDF R2,AC0 ;
MOV #OUTBUF,R0 ;
JSR PC,CVG ;Convert number to floating string in outbuf
MOV #OUTBUF,R0 ;
JSR PC,TYPSTR ;
.IFF
MOV (R2)+,R0 ;R0 ← first part
JSR PC,TYPOCT ;Type it
MOV #40,R0 ;
JSR PC,TYPCHR ; " "
MOV (R2),R0 ;
JSR PC,TYPOCT ;Type second part
.ENDC
CCC ;Clear condition code
RTS PC ;Done
; BREAK, NOOP, TOPAL, IOINIT
.IFZ ALAID
BREAK: ;Interpreter routine
MOV #BRKMES,R0 ;
JSR PC,TYPSTR ;
BPT ;Cause a DDT break
CCC ;Clear condition code
RTS PC ;Done
BRKMES: ASCIE </
PROGRAM BREAK/>
.ENDC
NOOP: ;Interpreter routine
CCC ;Clear condition code
RTS PC ;Done
TOPAL: ;Interpreter routine
COMMENT ⊗ Escape to PAL. JSRs to the pseudo code. That code
should return via:
MOV PC,R0
RTS PC
⊗
JSR PC,@IPC(R4) ;Fly
ADD #2,R0 ;R0 ← Proper new IPC
MOV R0,IPC(R4) ;Hope R4, R3 still OK!
RTS PC ;Done.
CSLEVT: 0 ;Console interlock event
IOINIT:
; Initialize the debugger. Leave all breakpoints as they are.
EVMAK ;
MOV (SP),CSLEVT ;
EVSIG ;Make a console interlock event
RTS PC ;